home *** CD-ROM | disk | FTP | other *** search
/ Best of www.BestZips.com (Collector's Edition) / Best of WWW.BESTZIPS.COM Collector's Edition (JCSM Shareware) (JCS Marketing).ISO / tutorial / adatu311.zip / JANUS32.PKG < prev    next >
Text File  |  1996-01-10  |  3KB  |  65 lines
  1. -- JANUS32.PKG   Ver. 3.11   10-JAN-1996   Copyright 1988-1996 John J. Herro
  2. --
  3. -- SOFTWARE INNOVATIONS TECHNOLOGY          http://members.aol.com/AdaTutor
  4. -- 1083 MANDARIN DR NE                      ftp://members.aol.com/AdaTutor
  5. -- PALM BAY FL 32905-4706
  6. --                                          johnherro@aol.com
  7. -- (407) 951-0233                           john.herro%374-38-2@satlink.oau.org
  8. --
  9. -- Compile this before compiling ADA_TUTR.ADA, when using a PC with a 32-bit
  10. -- version of Janus/Ada.
  11. --
  12. with Text2_IO; use Text2_IO;
  13. package Custom_IO is
  14.    type Color is (Black, Red, Green, Yellow, Blue, Magenta, Cyan, White);
  15.    Foregrnd_Color   : Color := White;                 -- Default values in case
  16.    Backgrnd_Color   : Color := Black;                 -- ADA-TUTR finds no User
  17.    Border_Color     : Color := Black;                 -- File.
  18.    Fore_Color_Digit : Character := Character'Val(Color'Pos(Foregrnd_Color)+48);
  19.    Back_Color_Digit : Character := Character'Val(Color'Pos(Backgrnd_Color)+48);
  20.    Normal_Colors    : String(1 .. 10) := ASCII.ESC & "[0;3" &
  21.                             Fore_Color_Digit & ";4" & Back_Color_Digit & "m";
  22.    Clear_Scrn       : constant String := ASCII.ESC & "[H" & ASCII.ESC &"[2J";
  23.  
  24.    procedure Set_Border_Color (To   : in  Color);
  25.    procedure Get              (Char : out Character);
  26.    procedure Put              (Char : in  Character) renames Text2_IO.Put;
  27.    procedure Put              (Str  : in  String)    renames Text2_IO.Put;
  28.    procedure Put_Line         (Str  : in  String)    renames Text2_IO.Put_Line;
  29.    procedure Get_Line         (Str  : out String;
  30.                                Last : out Natural)   renames Text2_IO.Get_Line;
  31.    procedure New_Line(Spacing : in Positive_Count := 1)
  32.                                                      renames Text2_IO.New_Line;
  33. end Custom_IO;
  34.  
  35. with Doscall, System; use Doscall, System;
  36. package body Custom_IO is
  37.     procedure Set_Border_Color(To : in Color) is
  38.         --
  39.         -- This procedure sets the border color on a PC by calling interrupt
  40.         -- 10 hex.  Before the call, register AH is set to service number
  41.         -- 0B hex, BH is set to zero, and BL is set to an integer as shown in
  42.         -- the declaration of Color_Number below.  Note that the integers in
  43.         -- Color_Number are bit reversed from the integers defining foreground
  44.         -- and background colors in ANSI escape sequences.  Note also that some
  45.         -- color PCs don't have separate border colors.
  46.         --
  47.         Regs         : Simple_Regs;
  48.         Color_Number : constant array(Color) of Long_Integer :=
  49.             (Black   => 0,   Red     => 4,   Green   => 2,   Yellow  => 6,
  50.              Blue    => 1,   Magenta => 5,   Cyan    => 3,   White   => 7);
  51.     begin
  52.         Regs.EAX := 16#0B00#;
  53.         Regs.EBX := 16#0000# + Color_Number(To);
  54.         Simple_Int_Call(Int_Num => 16#10#, Regs => Regs);
  55.     end Set_Border_Color;
  56.  
  57.     procedure Get(Char : out Character) is
  58.         Regs : Simple_Regs;
  59.     begin
  60.         Regs.EAX := 16#0800#;
  61.         Simple_Int_Call(Int_Num => 16#21#, Regs => Regs);
  62.         Char := Character'Val(Regs.EAX mod 128);
  63.     end Get;
  64. end Custom_IO;
  65.